home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d3 / db4less3.arc / FUNCODE.PRG < prev    next >
Encoding:
Text File  |  1990-06-16  |  14.8 KB  |  496 lines
  1. ********************************************************************************
  2. * Program......: FUNCODE
  3. * Author.......: Bruce Troutman
  4. * Date.........: 12-04-88
  5. * Notice.......: Type information here or greetings to your users.
  6. * dBASE Ver....: See Application menu to use as sign-on banner.
  7. * Generated by.: APGEN version 1.0
  8. * Description..: Function Code File Manager
  9.  
  10. * Notes........:
  11. ********************************************************************************
  12.  
  13. SET CONSOLE OFF
  14. IF TYPE("gn_apgen") = "U"  && We were not called from another APGEN program
  15.    CLEAR ALL
  16.    CLEAR WINDOW
  17.    CLOSE ALL
  18.    gn_apgen = 1
  19. ELSE
  20.    gn_apgen = gn_apgen + 1 
  21.    PRIVATE gc_bell, gc_carry, gc_clock, gc_century, gc_confirm, gc_deli,;
  22.            gc_escape, gc_instruc, gc_safety, gc_status, gc_score, gc_talk
  23. ENDIF
  24.  
  25. *-- Window for pause message box (ON ERROR)
  26. DEFINE WINDOW Pause FROM 15,00 TO 19,79 DOUBLE
  27. ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
  28. ON KEY LABEL F1 DO quickhlp
  29.  
  30. *-- Store initial SETs to variables
  31. gc_bell   =SET("BELL")
  32. gc_carry  =SET("CARRY")
  33. gc_clock  =SET("CLOCK")
  34. gc_century=SET("CENTURY")
  35. gc_confirm=SET("CONFIRM")
  36. gc_deli   =SET("DELIMITERS")
  37. gc_escape =SET("ESCAPE")
  38. gc_instruc=SET("INSTRUCT")
  39. gc_safety =SET("SAFETY")
  40. gc_status =SET("STATUS")
  41. gc_score  =SET("SCOREBOARD")
  42. gc_talk   =SET("TALK")
  43.  
  44. SET CLOCK OFF
  45. SET COLOR TO
  46. CLEAR
  47. SET CONSOLE ON
  48.  
  49. *-- Sets for application
  50. SET BELL ON
  51. SET CARRY OFF
  52. SET CENTURY OFF
  53. SET CONFIRM OFF
  54. SET DELIMITERS TO ""
  55. SET DELIMITER OFF
  56. SET ESCAPE ON
  57. ***SET INSTRUCT OFF ** remove for RunTime
  58. SET SAFETY ON
  59. SET SCOREBOARD OFF
  60. SET STATUS OFF
  61. SET TALK OFF
  62.  
  63. *-- Set global variables
  64. gn_barv  = 0                 && Initialize bar value variable
  65. gn_error = 0                 && Variable to store error() number
  66. gn_send  = 0                 && Return variable from popup
  67. gc_brdr  = "2"               && Border style for menu box - See Procedure
  68. lc_heading = "Function Code File Manager" && Menu heading string
  69. ll_color = ISCOLOR()
  70.  
  71. CLEAR
  72. SET ESCAPE ON
  73. SET STATUS ON
  74. *-- Set colors
  75. IF ll_color
  76.    SET COLOR OF NORMAL TO w+/b
  77.    SET COLOR OF MESSAGES TO w+/n
  78.    SET COLOR OF TITLES TO w/b
  79.    SET COLOR OF HIGHLIGHT TO b/w
  80.    SET COLOR OF BOX TO b/w
  81.    SET COLOR OF INFORMATION TO b/w
  82.    SET COLOR OF FIELDS TO b/w
  83. ENDIF
  84.  
  85. USE FUNCODE INDEX FUNCODE
  86. SET ORDER TO FUNCODE
  87.  
  88. *-- Define the main popup menu for Quickapp
  89. SET BORDER TO DOUBLE
  90. DEFINE POPUP quick FROM 7,27
  91. DEFINE BAR 1 OF quick PROMPT " Add Information" MESSAGE "Add records to database FUNCODE"
  92. DEFINE BAR 2 OF quick PROMPT " Change Information" MESSAGE "Edit records in database FUNCODE"
  93. DEFINE BAR 3 OF quick PROMPT " Browse Information" MESSAGE "Browse database FUNCODE"
  94. DEFINE BAR 4 OF quick PROMPT " Discard Marked Records " MESSAGE "Purge deleted records in database FUNCODE"
  95. DEFINE BAR 5 OF quick PROMPT " Print Report" MESSAGE "Run report form FUNCODE"
  96. DEFINE BAR 6 OF quick PROMPT " Reindex Database" MESSAGE "Reindex database FUNCODE"
  97. DEFINE BAR 7 OF quick PROMPT " Exit From Funcode" MESSAGE "Exit program to dBASE"
  98. ON SELECTION POPUP quick DO Action WITH BAR()
  99.  
  100. *-- Define the popup menu for print redirection
  101. DEFINE POPUP prntchk FROM 10,55
  102. DEFINE BAR 1 OF prntchk PROMPT " Send to..." SKIP
  103. DEFINE BAR 2 OF prntchk PROMPT REPLICATE(CHR(196),14) SKIP
  104. DEFINE BAR 3 OF prntchk PROMPT " Screen " MESSAGE "Screen only"
  105. DEFINE BAR 4 OF prntchk PROMPT " Printer " MESSAGE "Printer LPT1:"
  106. DEFINE BAR 5 OF prntchk PROMPT " Label Sample " MESSAGE "Printer LPT1: with Sample label"  SKIP
  107. DEFINE BAR 6 OF prntchk PROMPT " Return" MESSAGE "Return to Main Menu"
  108. ON SELECTION POPUP prntchk DO get_sele
  109.  
  110. *-- Window to cover work surface during edit, append, etc.
  111. DEFINE WINDOW work FROM 0,0 TO 21,79 NONE
  112.  
  113. *-- Window for area below menu heading & for running reports/labels in
  114. DEFINE WINDOW desktop FROM 4,0 TO 21,79 NONE
  115.  
  116. DEFINE WINDOW printemp FROM 10,25 TO 15,56
  117.  
  118. *-- Display heading centered on the screen.
  119. DO menubox WITH lc_heading
  120.  
  121. *-- Show the menu so we don't get a flash if the user hits arrow keys or ESC
  122. SHOW POPUP quick
  123. SAVE SCREEN TO quick
  124. *-- Display Quickapp menu centered on the screen.
  125. DO WHILE gn_barv <> 7 && Prevent user from exiting with arrow keys or ESC
  126.   ACTIVATE POPUP quick
  127. ENDDO
  128.  
  129. * Restore SET environment the best we can
  130. SET BELL &gc_bell.
  131. SET CARRY &gc_carry.
  132. SET CLOCK TO
  133. SET CLOCK &gc_clock.
  134. SET CENTURY &gc_century.
  135. SET CONFIRM &gc_confirm.
  136. SET DELIMITERS &gc_deli.
  137. SET ESCAPE &gc_escape.
  138. *** SET INSTRUCT &gc_instruc. ** Remove for RunTime
  139. SET STATUS &gc_status.
  140. SET SAFETY &gc_safety.
  141. SET SCORE  &gc_score.
  142. SET TALK   &gc_talk.
  143. SET FORMAT TO
  144.  
  145. IF gn_apgen = 1 && We were not called from another APGEN program
  146.    CLEAR WINDOW
  147.    CLEAR POPUP
  148.    CLEAR ALL
  149.    CLOSE ALL
  150. ELSE
  151.    RELEASE WINDOWS work, desktop 
  152.    RELEASE SCREEN quick
  153.    RELEASE POPUP quick
  154.    gn_apgen = gn_apgen - 1 
  155. ENDIF
  156. ON ERROR
  157. ON KEY LABEL F1
  158. RETURN
  159. * EOP: FUNCODE.PRG
  160.  
  161. ********************************************************************************
  162. * Procedures...: FUNCODE.Prc
  163. * Author.......: Bruce Troutman
  164. * Date.........: 12-04-88
  165. * Notice.......: Type information here or greetings to your users.
  166. * dBASE Ver....: See Application menu to use as sign-on banner.
  167. * Generated by.: APGEN version 1.0
  168. * Description..: Function Code File Manager
  169.  
  170. * Notes........:
  171. ********************************************************************************
  172.  
  173. *-- Here is a sample procedure file to show the power of procdures.
  174. *-- This example - Menubox displays a menu heading box with a centered heading.
  175. PROCEDURE MenuBox
  176. PARAMETER lc_m_name
  177. *-- Parameter lc_m_name - is the title variable for the menu
  178. SET CLOCK OFF
  179. @ 1,0 FILL TO 2,79 COLOR n/n
  180. DO CASE
  181. CASE gc_brdr = "0"
  182.    @ 1,0 CLEAR TO 3,79
  183. CASE gc_brdr = "1"
  184.    @ 1,0 TO 3,79
  185. CASE gc_brdr = "2"
  186.    lc_color = IIF(ISCOLOR(),"b/w", "W+/N")
  187.    @ 1,0 TO 3,79 DOUBLE COLOR &lc_color.
  188. ENDCASE
  189. SET CLOCK TO 2,68
  190. @ 2,1 SAY SUBSTR(CDOW(DATE()),1,3)+'. '+DTOC(DATE())+' '
  191. @ 2,41 - (LEN(lc_m_name)/2) SAY lc_m_name
  192. lc_color = IIF(ISCOLOR(),"w+/b", "W+/N")
  193. @ 2,1 FILL TO 2,78 COLOR &lc_color.
  194. RETURN
  195.  
  196.  
  197. PROCEDURE get_sele
  198. *-- Get the user selection & store BAR into variable
  199. gn_send = BAR()  && Variable for print testing
  200. DEACTIVATE POPUP
  201. RETURN
  202.  
  203. PROCEDURE Action
  204. PARAMETERS bar
  205. *-- Get the user selection & store BAR into variable
  206. gn_barv = bar
  207. SET MESSAGE TO
  208. IF LTRIM( STR( gn_barv)) $ "123"
  209.    *-- Set format file FUNCODE for edit/append/browse
  210.    SET FORMAT TO FUNCODE
  211. ENDIF
  212. DO CASE
  213.    CASE gn_barv = 1
  214.       *-- Add information
  215.       SET MESSAGE TO 'Appending records to file FUNCODE'
  216.       APPEND
  217.    CASE gn_barv = 2
  218.       *-- Change information
  219.       SET MESSAGE TO 'Editing file FUNCODE'
  220.       EDIT
  221.    CASE gn_barv = 3
  222.       *-- Browse information
  223.       SET MESSAGE TO 'Browsing file FUNCODE'
  224.       BROWSE FORMAT 
  225.    CASE gn_barv = 4
  226.       *-- Remove information (Pack file funcode)
  227.       ACTIVATE WINDOW desktop
  228.       @ 2,0 SAY "Packing database FUNCODE to REMOVE records marked for deletion..."
  229.       @ 3,0
  230.       SET TALK ON
  231.       PACK
  232.       GO TOP
  233.       ?
  234.       WAIT
  235.       SET TALK OFF
  236.       DEACTIVATE WINDOW desktop
  237.    CASE gn_barv = 5
  238.       *-- Run report form funcode
  239.       SET MESSAGE TO 'Pick an option to locate a record or <ESC> for default'
  240.       ACTIVATE WINDOW work
  241.       gn_recno = RECNO()
  242.       DO position
  243.       DEACTIVATE WINDOW work
  244.       lc_toprnt = IIF(gn_recno <> recno(),'REST ','')
  245.       STORE 0 TO gn_send, gn_pkey
  246.       ACTIVATE POPUP prntchk
  247.       IF gn_send = 4
  248.          lc_toprnt = 'TO PRINT'
  249.          ON ERROR DO prntrtry
  250.       ENDIF
  251.       IF .NOT. gn_send = 6
  252.          SET MESSAGE TO 'Printing report FUNCODE'
  253.          ACTIVATE WINDOW desktop
  254.          SET ESCAPE ON
  255.          REPORT FORM FUNCODE &lc_toprnt.
  256.          IF gn_pkey <> 27
  257.             WAIT
  258.          ENDIF
  259.          SET ESCAPE ON
  260.          DEACTIVATE WINDOW desktop
  261.       ENDIF
  262.       GOTO gn_recno
  263.       ON ERROR DO PAUSE WITH [Error occurred on line ]+LTRIM(STR(LINE())) +[ of procedure ]+Program()
  264.    CASE gn_barv = 6
  265.       *-- Reindex funcode
  266.       ACTIVATE WINDOW desktop
  267.       @ 3,0 SAY "Reindexing database FUNCODE..."
  268.       @ 4,0
  269.       SET TALK ON
  270.       REINDEX
  271.       GO TOP
  272.       ?
  273.       WAIT
  274.       SET TALK OFF
  275.       DEACTIVATE WINDOW desktop
  276.    CASE gn_barv = 7
  277.       DEACTIVATE POPUP
  278. ENDCASE
  279. SET MESSAGE TO
  280. IF gc_status = "OFF"
  281.    SET STATUS ON
  282. ENDIF
  283. SET FORMAT TO
  284. RESTORE SCREEN FROM quick
  285. RETURN
  286.  
  287. PROCEDURE Pause
  288. PARAMETER lc_msg
  289. *-- Parameters : lc_msg = message line
  290. IF TYPE("lc_message")="U"
  291.    gn_error=ERROR()
  292. ENDIF
  293. lc_msg = lc_msg
  294. lc_option='0'
  295. ACTIVATE WINDOW Pause
  296. IF gn_error > 0
  297.    IF TYPE("lc_message")="U"
  298.       @ 0,1 SAY [An error has occurred !! - Error message: ]+MESSAGE()
  299.    ELSE
  300.       @ 0,1 SAY [Error # ]+lc_message
  301.    ENDIF
  302. ENDIF
  303. @ 1,1 SAY lc_msg
  304. WAIT " Press any key to continue..."
  305. DEACTIVATE WINDOW Pause
  306. RETURN
  307.  
  308.  
  309. PROCEDURE quickhlp
  310. *--  If you want to include help for a quickapp uncomment the lines below and
  311. *--  put your help @ say's into the case statements
  312. *ACTIVATE WINDOW desktop
  313. *CLEAR
  314. DO CASE
  315.   CASE BAR() = 1
  316.   CASE BAR() = 2
  317.   CASE BAR() = 3
  318.   CASE BAR() = 4
  319.   CASE BAR() = 5
  320.   CASE BAR() = 6
  321.   CASE BAR() = 7
  322. ENDCASE
  323. *WAIT
  324. *DEACTIVATE WINDOW desktop
  325. RETURN
  326.  
  327. PROCEDURE Position
  328. IF LEN(DBF()) = 0
  329.    DO Pause WITH "Database not in use. "
  330.    RETURN
  331. ENDIF
  332. SET SPACE ON
  333. SET DELIMITERS OFF
  334. ln_type=0          && sublevel selection
  335. ln_rkey=READKEY()  && test for ESC or Return
  336. ln_rec=RECNO()     && DBF record number
  337. ln_num=0           && for input of a number
  338. ld_date=DATE()     && for input of a date
  339. lc_option='0'      && main option ie. Seek, Goto and Locate
  340. *-- Scope ie. ALL, REST, NEXT <n>
  341. STORE SPACE(10) TO lc_scp
  342. *-- 1 = Character SEEK, 2 = For clause, 3 = While clause
  343. STORE SPACE(40) TO lc_ln1, lc_ln2, lc_ln3
  344. lc_temp=""
  345. @ 0,00 SAY "Index order: "+IIF(""=ORDER(),"Database is in natural order",ORDER())
  346. @ 1,00 SAY "Listed below are the first 16 fields."
  347. lc_temp=REPLICATE(CHR(196),19)
  348. @ 2,0 SAY CHR(218)+lc_temp+CHR(194)+lc_temp+CHR(194)+lc_temp+CHR(194)+lc_temp
  349. ln_num=240
  350. DO WHILE ln_num < 560
  351.    lc_temp=FIELD( (ln_num-240)/20 +1)
  352.    @ (ln_num/80),MOD(ln_num,80) SAY CHR(179)+;
  353. lc_temp+SPACE(11-LEN(lc_temp))+;
  354. SUBSTR("= Char  = Date  = Logic = Num   = Float = Memo          ",;
  355. AT(TYPE(lc_temp),"CDLNFMU")*8-7,8)
  356.    ln_num=ln_num+20
  357. ENDDO
  358. ln_num=1
  359.  
  360. DEFINE POPUP Posit1 FROM 8,30
  361. DEFINE BAR 1 OF Posit1 PROMPT " Position by " SKIP
  362. DEFINE BAR 2 OF Posit1 PROMPT REPLICATE(CHR(196),15) SKIP
  363. DEFINE BAR 3 OF Posit1 PROMPT " SEEK Record" MESSAGE "Search on index key" SKIP FOR ""=ORDER()
  364. DEFINE BAR 4 OF Posit1 PROMPT " GOTO Record" MESSAGE "Position to specific record"
  365. DEFINE BAR 5 OF Posit1 PROMPT " LOCATE Record " MESSAGE "Locate record for condition"
  366. DEFINE BAR 6 OF Posit1 PROMPT " Return" MESSAGE "Return without positioning"
  367. ON SELECTION POPUP Posit1 DO get_sele
  368.  
  369. SET CONFIRM ON
  370. DO WHILE lc_option='0'
  371.   ACTIVATE POPUP Posit1
  372.   lc_option = ltrim(str(gn_send))  && for popup
  373.    IF LASTKEY() = 27 .OR. lc_option="6"
  374.       GOTO ln_rec
  375.       EXIT
  376.    ENDIF
  377.    DO CASE
  378.    CASE lc_option='3'
  379.       *-- Seek
  380.       IF LEN(NDX(1))=0 .AND. LEN(MDX(1))=0
  381.          DO Pause WITH "Can't use this option - No index files are open."
  382.          LOOP
  383.       ENDIF
  384.       ln_type=1
  385.       lc_ln1=SPACE(40)
  386.       DEFINE WINDOW Posit2 FROM 8,19 TO 15,62 DOUBLE
  387.       ACTIVATE WINDOW Posit2
  388.       @ 1,1 SAY "Enter the type of expression:" GET ln_type PICT "#" RANGE 1,3
  389.       @ 2,1 SAY "(1=character, 2=numeric and 3=date.)"
  390.       READ
  391.       IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
  392.          SET CONFIRM ON
  393.          @ 3,1 SAY "Enter the key expression to search for:"
  394.          IF ln_type=3
  395.             @ 4,1 GET ld_date PICT "@D"
  396.          ELSE
  397.             IF ln_type=2
  398.                @ 4,1 GET ln_num PICT "##########"
  399.             ELSE
  400.                @ 4,1 GET lc_ln1
  401.             ENDIF
  402.          ENDIF
  403.          READ
  404.          SET CONFIRM OFF
  405.          IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
  406.             lc_temp=IIF(ln_type=1,"TRIM(lc_ln1)",IIF(ln_type=2,"ln_num","ld_date"))
  407.             SEEK &lc_temp.
  408.          ENDIF
  409.       ENDIF
  410.       RELEASE WINDOWS Posit2
  411.    CASE lc_option='4'
  412.       *-- Goto
  413.       ln_type=1
  414.       DEFINE POPUP Posit2 FROM 8,30
  415.       DEFINE BAR 1 OF Posit2 PROMPT " GOTO:" SKIP 
  416.       DEFINE BAR 2 OF Posit2 PROMPT REPLICATE(CHR(196),10) SKIP 
  417.       DEFINE BAR 3 OF Posit2 PROMPT " TOP" MESSAGE "GOTO Top of File"
  418.       DEFINE BAR 4 OF Posit2 PROMPT " BOTTOM" MESSAGE "GOTO Bottom of File"
  419.       DEFINE BAR 5 OF Posit2 PROMPT " Record # " MESSAGE "GOTO A Specific Record"
  420.       ON SELECTION POPUP Posit2 DO get_sele
  421.       ACTIVATE POPUP posit2
  422.       ln_type = gn_send
  423.       IF LASTKEY() <> 27
  424.          IF ln_type=5
  425.             DEFINE WINDOW Posit2 FROM 8,26 TO 13,50 DOUBLE
  426.             ACTIVATE WINDOW Posit2
  427.             ln_num=0
  428.             @ 3,1 SAY "Max. Record # = "+LTRIM(STR(RECCOUNT()))
  429.             @ 1,1 SAY "Record to GOTO" GET ln_num PICT "######" RANGE 1,RECCOUNT()
  430.             READ
  431.             IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
  432.                GOTO ln_num
  433.             ENDIF
  434.             RELEASE WINDOWS Posit2
  435.          ELSE
  436.            lc_temp=IIF(ln_type=3,"TOP","BOTTOM")
  437.            GOTO &lc_temp.
  438.          ENDIF
  439.       ENDIF
  440.    CASE lc_option='5'
  441.       *-- Locate
  442.       DEFINE WINDOW Posit2 FROM 8,16 TO 14,66 DOUBLE
  443.       ACTIVATE WINDOW Posit2
  444.       @ 1,19 SAY "ie. ALL, NEXT <n>, and REST"
  445.       @ 1,01 SAY "Scope:" GET lc_scp
  446.       @ 2,01 SAY "For:  " GET lc_ln2
  447.       @ 3,01 SAY "While:" GET lc_ln3
  448.       READ
  449.       IF .NOT. (READKEY() = 12 .OR. READKEY() = 268)
  450.          lc_temp=TRIM(lc_scp)
  451.          lc_temp=lc_temp + IIF(LEN(TRIM(lc_ln2)) > 0," FOR "+TRIM(lc_ln2),"")
  452.          lc_temp=lc_temp + IIF(LEN(TRIM(lc_ln3)) > 0," WHILE "+TRIM(lc_ln3),"")
  453.          IF LEN(lc_temp) > 0
  454.             LOCATE &lc_temp.
  455.          ELSE
  456.             DO Pause WITH "All fields were blank."
  457.          ENDIF
  458.       ENDIF
  459.       RELEASE WINDOW Posit2
  460.    ENDCASE
  461.    IF EOF()
  462.       DO Pause WITH "Record not found."
  463.       GOTO ln_rec
  464.    ENDIF
  465.    IF READKEY()=12 .OR. READKEY()= 268 .OR. LASTKEY()=27  && Esc was hit
  466.       lc_option='0'
  467.    ENDIF
  468. ENDDO
  469. SET DELIMITERS &gc_deli.
  470. SET CONFIRM OFF
  471. RETURN
  472.  
  473.  
  474. PROC prntrtry
  475. PRIVATE lc_escape
  476. lc_escape = SET("ESCAPE")
  477. IF .NOT. PRINTSTATUS()
  478.    IF lc_escape = "ON"
  479.        SET ESCAPE OFF
  480.     ENDIF
  481.    gn_pkey = 0
  482.    ACTIVATE WINDOW printemp
  483.    @ 1,0 SAY "Please ready your printer or"
  484.    @ 2,0 SAY "     press ESC to cancel"
  485.    DO WHILE ( .NOT. PRINTSTATUS()) .AND. gn_pkey <> 27
  486.       gn_pkey = INKEY()
  487.    ENDDO
  488.    DEACTIVATE WINDOW printemp
  489.    SET ESCAPE &lc_escape
  490.    IF gn_pkey <> 27
  491.       RETRY
  492.    ENDIF
  493. ENDIF
  494. RETURN
  495. * EOF: FUNCODE.PRG
  496.